home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d18
/
techjock.arc
/
IOTTT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-11-18
|
21KB
|
639 lines
{S-,R-,V-,D-,T-}
{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
{ TechnoJocks Turbo Toolkit v4.00 Released: Feb 1, 1988 }
{ }
{ Module: IOTTT -- screen input/editing routines }
{ }
{ Copyright R. D. Ainsbury (c) 1986 }
{\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
unit IOTTT;
interface
uses CRT,FastTTT,DOS,WinTTT,KeyTTT;
CONST
MaxInputFields = 40; {alter as necessary}
TYPE
Str_Field_Defn = record
Upfield : byte;
Downfield : byte;
Leftfield : byte;
Rightfield: byte;
X : byte;
Y : byte;
InString : ^string;
StrLength : byte;
Format : string;
Message : string;
MsgX : byte;
MsgY : byte;
CursorX : byte;
CursorInit: byte;
StrLocX : byte;
end;
Str_Field_Ptr = ^Str_Field_Defn;
InputZone = record
HiF : byte;
HiB : byte;
LoF : byte;
LoB : byte;
MsgF : byte;
MsgB : byte;
TotalFields: byte;
CurrentField : byte;
IOEsc : boolean;
IO_FieldsSet : boolean;
Displayed : boolean;
IO_Beepon : boolean;
IO_Putunderline : boolean;
IO_Insert : boolean;
end;
CONST
IO_Settings : InputZone= (HiF:white;
HiB:blue;
LoF:blue;
LoB:lightgray;
MsgF:yellow;
MsgB:red;
TotalFields:MaxInputFields;
CurrentField : 1;
IOEsc : false;
IO_FieldsSet : false;
Displayed : false;
IO_BeepOn : true;
IO_PutUnderline: true;
IO_Insert : false);
var
FieldDefn : array[0..MaxInputFields] of Str_Field_Ptr;
IO_UserHook : pointer;
Procedure IO_Setfields(No_of_fields:byte);
Procedure IO_SetColors(HiFore,Hiback,LoFore,LoBack,MsgFore,MsgBack:byte);
Procedure IO_DefineMsg(DefID,DefX,DefY : byte; DefString : string);
Procedure IO_DefineStr(DefID,DefU,DefD,DefL,DefR,DefX,DefY:byte;
Var DefString : string;
DefFormat : string);
Procedure IO_DisplayFields;
Procedure IO_AllowEsc(OK:boolean);
Procedure IO_SoundBeeper(OK:boolean);
Procedure IO_ResetFields;
Procedure IO_Edit(var Return_code : integer);
implementation
Const
FmtChars : set of char = ['!','#','@','*'];
IOUp = #200;
IODown = #208;
IORight = #205;
IOLeft = #203;
IODel = #211;
IOTotErase = #146; {Alt-E}
IOErase = #160; {Alt-D}
IOFinish = #207; {End} {maybe change to F10}
IOEsc = #27;
IOTab = #9;
IOShiftTab = #143;
IOEnter = #13;
IOIns = #210;
IOBackSp = #8;
IORightFld = #244;
IOLeftFld = #243;
IOHelp = #187;
Procedure CallFromIO(Ch: char; FieldID:integer;var ReturnStr:string);
Inline($FF/$1E/IO_UserHook);
Function Int_to_Str(Number:Integer):string;
var Temp : string;
begin
Str(Number,temp);
Int_to_Str := temp;
end;
function Real_to_str(Number:real;Decimals:byte):string;
var Temp : string;
begin
Str(Number:20:Decimals,Temp);
repeat
If copy(Temp,1,1) = ' ' then delete(Temp,1,1);
until copy(temp,1,1) <> ' ';
Real_to_Str := Temp;
end;
Function Str_to_Int(Str:string):integer;
var temp,code : integer;
begin
If length(Str) = 0 then
Str_to_Int := 0
else
begin
val(Str,temp,code);
if code = 0 then
Str_to_Int := temp
else
Str_to_Int := 0;
end;
end;
Procedure IOError(Code:byte;value:real); {fatal error -- msg and halt}
var Message:string;
begin
{Clrscr;}
Case Code of
1 : Message := 'Fatal Error 1: Invalid value of '+Real_to_Str(value,0)
+' in IO_SetFields with a MaxInputFields of '
+Real_to_Str(MaxInputFields,0);
2 : Message := 'Fatal Error 2 : Insufficient Memory on Heap. Available '
+Real_to_Str(MaxAvail,0)+'. Required '
+Real_to_Str(value,0);
3 : Message := 'Fatal Error 3 : Define IO_Setfields before IO_DefineStr';
4 : Message := 'Fatal Error 4 : IO_DefineStr ID: '
+Real_to_Str(value,0)+' out of range';
5 : Message := 'Fatal Error 5 : Invalid exit field defined in IO_DefinStr ID: '
+Real_to_Str(value,0);
6 : message := 'Fatal Error 6 : Invalid X or Y value defined in IO_DefineStr ID: '
+Real_to_Str(value,0);
7 : Message := 'Fatal Error 7 : Define IO_Setfields before IO_DefineMsg';
8 : Message := 'Fatal Error 8 : IO_DefineMsg ID: '+Real_to_Str(value,0)
+' out of range';
9 : message := 'Fatal Error 9 : Invalid X or Y value defined in IO_DefineMsg ID: '
+Real_to_Str(value,0);
10 : Message := 'Fatal Error 10 : Only use IO_ResetFields after IO_Setfields';
11 : Message := 'Fatal Error 11 : IO_Setfields already operative,'
+' reset with IO_Resetfields';
else Message := 'Aborting';
end; {case}
WriteAT(1,12,black,lightgray,Message);
Repeat Until keypressed;
Halt;
end; {proc IOError}
Procedure Ding;
begin
If IO_Settings.IO_BeepOn then
sound(750);delay(150);nosound;
end; {proc Ding}
Procedure InsertMode; {change cursor style when in insert mode}
begin
IO_Settings.IO_Insert := not IO_Settings.IO_Insert;
If IO_Settings.IO_Insert then
HalfCursor
else
OnCursor;
end;
Procedure IO_Setfields(No_of_fields:byte);
var
I:integer;
Room_needed : integer;
begin
If IO_Settings.IO_FieldsSet then IOError(11,0); {already set}
If No_of_Fields in [1..MaxInputFields] then
begin
Room_needed := sizeof(FieldDefn[0]^);
For I := 0 to No_of_fields do
begin
If MaxAvail >= Room_needed then
begin
GetMem(FieldDefn[I],Room_Needed);
with FieldDefn[I]^ do
begin
Upfield := 0;
Downfield := 0;
Leftfield := 0;
Rightfield := 0;
X := 0;
Y := 0;
StrLength := 0;
Format := '';
Message := '';
MsgX := 81; {zero means auto-center}
MsgY := 0;
CursorX := 0;
CursorInit := 0;
StrLocX := 1;
end; {With}
end
else {not enough heap space}
IOError(2,Room_needed); {end MemAvail If clause}
end;
IO_Settings.TotalFields := No_of_Fields;
IO_Settings.IO_FieldsSet := true;
end
else {Invalid No_of_fields}
IOError(1,No_of_fields);
end; {Proc IO_SetFields}
Procedure IO_SetColors(HiFore,Hiback,LoFore,LoBack,MsgFore,MsgBack:byte);
begin
With IO_Settings do
begin
HiF := HiFore;
HiB := HiBack;
LoF := LoFore;
LoB := LoBack;
MsgF := MsgFore;
MsgB := MsgBack;
end;
end; {Proc IO_SetColors}
Procedure IO_DefineMsg(DefID,DefX,DefY : byte; DefString : string);
begin
If not IO_Settings.IO_FieldsSet then IOError(7,0);
If (DefID < 1) or (DefID > IO_Settings.TotalFields) then IOError(8,DefID);
If (DefX < 0) or (DefX > 80) or (DefY < 1) or (DefY > 25) then IOError(9,DefID);
With FieldDefn[Defid]^ do
begin
MsgX := DefX;
MsgY := DefY;
Message := DefString;
end;
end; {proc IO_DefineMsg}
Procedure IO_DefineStr(DefID,DefU,DefD,DefL,DefR,DefX,DefY:byte;
Var DefString : string;
DefFormat : string);
Function Max_string_length : byte;
var I,Counter : byte;
begin
Counter := 0;
For I := 1 to length(DefFormat) do
if (DefFormat[I] in FmtChars) then
Counter := succ(counter);
Max_string_length := Counter;
end; {sub func Max_String_Length}
Function Pos_of_First_Input_Char: byte;
var Counter : byte;
begin
Counter := 0;
Repeat
Counter := succ(Counter);
Until DefFormat[Counter] in FmtChars;
Pos_of_First_Input_Char := FieldDefn[DefID]^.X + counter - 1;
end;
begin
If not IO_Settings.IO_FieldsSet then IOError(3,0);
If (DefID < 1) or (DefID>IO_Settings.TotalFields) then IOError(4,Defid);
If (DefU < 0) or (DefU > IO_Settings.TotalFields)
or (DefD < 0) or (DefD > IO_Settings.TotalFields)
or (DefL < 0) or (DefL > IO_Settings.TotalFields)
or (DefR < 0) or (DefR > IO_Settings.TotalFields)
then IOError(5,Defid);
If (DefX < 1) or (DefX > 80)
or (DefY < 1) or (DefY > 25)
then IOError(6,Defid);
With FieldDefn[DefID]^ do
begin
Upfield := DefU;
Downfield := DefD;
Leftfield := DefL;
Rightfield := DefR;
X := DefX;
Y := DefY;
InString := ptr(seg(defstring),ofs(defstring));
StrLength := Max_String_length;
Format := DefFormat;
CursorX := Pos_of_First_Input_Char;
CursorInit := Pos_of_First_Input_Char;
end;
end; {proc IO_DefineStr}
Function IO_FmtStr(Str,Fmt:string):string;
var
TempStr : string;
I,J : byte;
begin
J := 0;
For I := 1 to length(Fmt) do
begin
If not (Fmt[I] in FmtChars) then
begin
TempStr[I] := Fmt[I] ; {force any none format charcters into string}
J := succ(J);
end
else {format character}
begin
If I - J <= length(Str) then
TempStr[I] := Str[I - J]
else
TempStr[I] := '_'; {pad with underlines}
end;
end;
TempStr[0] := char(length(Fmt)); {set initial byte to string length}
IO_FmtStr := Tempstr;
end; {Func FmtStr}
Procedure Hilight(ID:byte); {display cell in bright colors}
begin
with FieldDefn[ID]^ do
WriteAT(X,Y,IO_Settings.HiF,IO_Settings.HiB,
IO_FmtStr(InString^,Format));
end;
Procedure LoLight(ID:byte); {display cell in dim colors}
begin
with FieldDefn[ID]^ do
WriteAT(X,Y,IO_Settings.LoF,IO_Settings.LoB,
IO_FmtStr(InString^,Format));
end;
Procedure IO_DisplayFields;
var I : integer;
begin
For I := 1 to IO_Settings.TotalFields do
LoLight(I);
IO_Settings.Displayed := true;
end;
Procedure IO_AllowEsc(OK:boolean);
begin
IO_Settings.IOEsc := OK;
end; {proc IO_AllowEsc}
Procedure IO_SoundBeeper(OK:boolean);
begin
IO_Settings.IO_BeepOn := OK;
end; {proc IO_SoundBeeper}
Procedure IO_ResetFields;
var I : integer;
begin
If not IO_Settings.IO_FieldsSet then IOError(10,0);
IO_UserHook := nil;
For I := 0 to IO_Settings.TotalFields do
FreeMem(FieldDefn[I],sizeof(FieldDefn[I]^));
With IO_Settings do
begin
IO_FieldsSet := false;
TotalFields := 0;
IOEsc := false;
Displayed := false;
IO_Beepon := true;
IO_PutUnderline := true;
IO_Insert := false;
CurrentField := 1;
end; {with}
IO_UserHook := nil;
end; { proc IO_ResetFields }
{
****************************
* Main Procedure *
****************************
}
Procedure IO_Edit(var Return_code : integer);
const
finished : boolean = false;
var
OldLine : array[1..160] of byte;
Procedure DisplayMessage(ID:byte);
begin
With FieldDefn[ID]^ do
begin
If MsgX = 0 then {Center the message}
MsgX := (80 - length(Message)) div 2;
PartSave(MsgX,MsgY,MsgX+length(Message),MsgY,OldLine);
WriteAT(MsgX,MsgY,IO_Settings.MsgF,IO_Settings.MsgB,Message);
end; {sub sub proc DisplayMessage}
end;
Procedure RemoveMessage(ID:byte);
var I,LocC : integer;
begin
With FieldDefn[ID]^ do
PartRestore(MsgX,MsgY,MsgX+length(Message),MsgY,OldLine);
end; {sub sub proc RemoveMessage}
Procedure Change_Fields(ID:byte);
begin
LoLight(IO_Settings.CurrentField);
If FieldDefn[IO_Settings.CurrentField]^.MsgX <= 80 then
RemoveMessage(IO_Settings.CurrentField);
If ID = 0 then
begin
Finished := true;
Return_Code := 0;
end
else
begin
IO_Settings.CurrentField := ID;
If IO_Settings.IO_Insert = true then {switch insert off}
InsertMode;
HiLight(IO_Settings.CurrentField);
If FieldDefn[IO_Settings.CurrentField]^.MsgX <= 80 then
DisplayMessage(IO_Settings.CurrentField);
With FieldDefn[IO_Settings.CurrentField]^ do
GotoXY(CursorX,Y);
Ding;
end; {If ID = 0};
end; {proc change fields}
Procedure Erase_Field(ID:byte);
begin
with FieldDefn[ID]^ do
begin
Instring^ := '';
CursorX := CursorInit;
StrLocX := 1;
end;
end;
Procedure Global_Erase;
var I : integer;
begin
{MayBe paint an are you sure window}
For I := 1 to IO_Settings.TotalFields do
Erase_Field(I);
IO_DisplayFields;
IO_Settings.CurrentField := 1;
end;
Procedure Cursor_Right;
begin
With FieldDefn[IO_Settings.CurrentField]^ do
begin
If (StrLocX <= length(InString^)) and (StrLocX < StrLength) then
begin
StrLocX := succ(StrLocX);
Repeat
CursorX := succ(CursorX);
Until Format[CursorX + 1 - X] in FmtChars;
end;
GotoXY(CursorX,Y);
end; {with}
end; {Proc Cursor_Right}
Procedure Cursor_Left;
begin
With FieldDefn[IO_Settings.CurrentField]^ do
begin
If StrLocX > 1 then
begin
StrLocX := pred(StrLocX);
Repeat
CursorX := CursorX - 1;
Until Format[CursorX + 1 - X] in FmtChars;
end;
end; {with}
end; {Proc Cursor_left}
Procedure Delete_Char;
var
Temp : boolean;
I : integer;
begin
Temp := false; {insert a space if there are}
with FieldDefn[IO_Settings.CurrentField]^ do {non format characters}
begin
For I := 1 to length(Format) do
If not (Format[I] in FmtChars) then
Temp := true;
Delete(InString^,StrLocX,1);
If Temp = true then
Insert(' ',Instring^,StrlocX);
end; {with}
end; {Delete_Chars}
Procedure Backspaced;
begin
with FieldDefn[IO_Settings.CurrentField]^ do
begin
If StrLocX > 1 then
begin
Cursor_Left;
Delete(InString^,StrLocX,1);
end;
end; {with}
end; { Proc Backspaced }
Procedure Activity;
var
K : char;
ReturnStr: string;
Prior_CursorX : byte;
begin
K := Getkey;
If IO_UserHook <> nil then
begin
ReturnStr := '';
CallFromIO(K,IO_Settings.CurrentField,ReturnStr);
If ReturnStr <> '' then
with FieldDefn[IO_Settings.CurrentField]^ do
begin
InString^ := copy(ReturnStr,1,StrLength);
CursorX := X;
StrLocX := 1;
Repeat
Prior_CursorX := CursorX;
Cursor_Right;
Until CursorX = Prior_CursorX;
end;
end;
Case K of
#132, {mouse right but}
IOEsc : If IO_Settings.IOEsc then
begin
Finished := true;
Return_Code := 1;
end
else Ding;
IOFinish : begin
Finished := true;
Return_code := 0;
end;
#32..#126 : with FieldDefn[IO_settings.CurrentField]^ do
begin
If Format[CursorX - X + 1] = '!' then K := upcase(K);
If ((K in ['0'..'9','.','-','e','E']) and (Format[CursorX - X + 1] = '#'))
or ((K in ['a'..'z','A'..'Z',' ',',','.',';',':']) and
(Format[CursorX - X + 1] = '@'))
or (Format[CursorX - X + 1] = '*')
or (Format[CursorX - X + 1] = '!') then
begin
If IO_Settings.IO_Insert then {in insert mode}
begin
If length(Instring^) < StrLength then
begin
Insert(K,Instring^,StrLocX);
Cursor_Right;
end
else Ding;
end
else {in overlay mode}
begin
Delete(Instring^,StrLocX,1);
Insert(K,Instring^,StrLocX);
Cursor_Right;
end; {If insert}
end
else Ding; {end if K in statement}
end; {with}
#133, {mouse left but}
#131, {mouse right}
IORightFld,
IOTab,
IOEnter : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.RightField);
#130, {mouse left}
IOLeftFld,
IOShiftTab :Change_Fields(FieldDefn[IO_Settings.CurrentField]^.LeftField);
IOBackSp : Backspaced;
IODel : Delete_Char;
IOLeft : Cursor_Left;
IORight : Cursor_Right;
#128, {mouse up}
IOUp : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.UpField);
#129, {mouse down}
IODown : Change_Fields(FieldDefn[IO_Settings.CurrentField]^.DownField);
IOErase : Erase_Field(IO_Settings.CurrentField);
IOTotErase : Global_Erase;
IOIns : InsertMode;
else Ding;
end; {case}
HiLight(IO_Settings.CurrentField);
With FieldDefn[IO_Settings.CurrentField]^ do
GotoXY(CursorX,Y);
end; {Proc Activity}
begin {IO_Edit}
If IO_Settings.Displayed = false then IO_DisplayFields;
Hilight(IO_Settings.CurrentField);
If FieldDefn[IO_Settings.CurrentField]^.MsgX <= 80 then
DisplayMessage(IO_Settings.CurrentField);
GotoXY(FieldDefn[IO_Settings.CurrentField]^.CursorX,
FieldDefn[IO_Settings.CurrentField]^.Y);
Finished := false;
repeat
Activity
until Finished;
end; {IO_Edit}
begin {Initial Auto proc}
IO_UserHook := nil;
If BaseOfScreen = $B000 then
IO_SetColors(black,lightgray,lightgray,black,white,black);
end.